home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / vm_system.t < prev    next >
Text File  |  1988-02-05  |  6KB  |  182 lines
  1. (herald vm_system (env tsys))
  2.  
  3. ;;; This switch is modified by the suspender when a 
  4. ;;; system is released.
  5.  
  6. (define-simple-switch experimental? boolean? t)
  7.  
  8. ;;; Accessors for system and task global values.
  9. ;++ These are redefined here because the compiler can't
  10. ;++ produce the closed compiled forms.
  11.  
  12. (define PROCESS-GLOBAL
  13.   (let ((slot (lambda (offset)
  14.                 (fx-ashr (fx- (fx+ (fx-negate %%task-header-offset) offset) 4) 2))))
  15.     (object (lambda (offset)
  16.               (extend-elt (current-task) (slot offset)))
  17.       ((setter self)
  18.        (lambda (offset val)
  19.          (set (extend-elt (current-task) (slot offset)) val))))))
  20.  
  21. (define SYSTEM-GLOBAL
  22.   (let ((slink-offset (lambda (n) (fx- (fx-ashr (fx+ n 3) 2) 1))))
  23.     (object (lambda (offset)
  24.               (extend-elt (gc-pair->extend *the-slink*)
  25.                           (slink-offset offset)))
  26.       ((setter self)
  27.        (lambda (offset val)
  28.          (set (extend-elt (gc-pair->extend *the-slink*)
  29.                           (slink-offset offset)) val))))))
  30.  
  31. ;;; ---------- Processor
  32.  
  33. (define-operation (processor-type processor))
  34. (define-predicate mc68000-processor?)
  35. (define-predicate vax-processor?)
  36.  
  37. ;;; ---------- Operating system
  38.  
  39. (define-operation (object-file-type      os))
  40. (define-operation (information-file-type os))
  41. (define-operation (noise-file-type       os))
  42. (define-operation (os-type os))
  43. (define-operation (machine-type os))
  44. (define-operation (page-size os))
  45. (define-predicate aegis-os?)
  46. (define-predicate unix-os?)
  47. (define-predicate vms-os?)
  48.  
  49. ;;; ---------- Embedded systems
  50.  
  51. (lset *embedded-systems* '())
  52.  
  53. (define (system-present? name)                 ;++ useful?
  54.   (any? (lambda (system)
  55.           (eq? (system-name system) name))
  56.         *embedded-systems*))
  57.  
  58. (define-operation (system-name          system))
  59. (define-operation (major-version        system))
  60. (define-operation (minor-version        system))
  61. (define-operation (link-edit            system))
  62. (define-operation (build-date           system))
  63. (define-operation (initialize           system))
  64. (define-operation (re-initialize        system))
  65. (define-operation (configure-system     system))
  66. (define-operation (set-system-edit      system)) ;??
  67. (define-operation (system-modules       system))
  68.  
  69. (define-structure-type system
  70.                        %name
  71.                        %major
  72.                        %minor
  73.                        %link-edit
  74.                        %build-date
  75.                        %note
  76.                        %initializer
  77.                        %re-initializer
  78.                        %configurer       ; local modifications
  79.                        %modules          ; source tree
  80.   (((major-version self)        (system-%major self))
  81.    ((minor-version self)        (system-%minor self))
  82.    ((link-edit self)            (system-%link-edit self))
  83.    ((build-date self)           (system-%build-date self))
  84.    ((set-system-edit self n)    (set (system-%link-edit self) n))
  85.    ((initialize        self)    ((system-%initializer self) self))
  86.    ((re-initialize     self)    ((system-%re-initializer self) self))
  87.    ((configure-system self)     ((system-%configurer self) self))
  88.    ((system-name self)          (system-%name self))
  89.    ((system-modules self)       (system-%modules self))
  90.    ((print self port)
  91.     (format port "~&~a~a ~s.~s (~s) ~a/~a  ~a~%"
  92.             (system-%name  self)
  93.             (if (experimental?) " (Beta)" "")
  94.             (system-%major self)
  95.             (system-%minor self)
  96.             (system-%link-edit  self)
  97.             (processor-type (local-processor))
  98.             (os-type (local-os))
  99.             (system-%note self)))))
  100.  
  101. (set (system-%major          (stype-master system-stype)) 3)
  102. (set (system-%minor          (stype-master system-stype)) 0)
  103. (set (system-%link-edit      (stype-master system-stype)) 0)
  104. (set (system-%note           (stype-master system-stype)) "")
  105. (set (system-%initializer    (stype-master system-stype)) true)
  106. (set (system-%re-initializer (stype-master system-stype)) true)
  107. (set (system-%configurer     (stype-master system-stype)) true)
  108.  
  109. (define (create-system name major minor link
  110.                        init re-init config note modules)
  111.   (let ((sys  (make-system)))
  112.     (set (system-%name           sys) name)
  113.     (set (system-%major          sys) major)
  114.     (set (system-%minor          sys) minor)
  115.     (set (system-%link-edit      sys) link)
  116.     (set (system-%initializer    sys) init)
  117.     (set (system-%re-initializer sys) re-init)
  118.     (set (system-%configurer     sys) config)
  119.     (set (system-%note           sys) note)
  120.     (set (system-%modules        sys) modules)
  121.     (push *embedded-systems* sys)
  122.     sys))
  123.  
  124.  
  125. ;;; ---------- The Virtual Machine
  126.  
  127. ;;; The VM must be the first embedded system.
  128.  
  129. (define t-copyright-notice "Copyright (C) 1986 Yale University")
  130.  
  131. (define vm-system
  132.   (create-system "Virtual Machine" 1 0 2
  133.                  initialize-virtual-machine
  134.                  re-initialize-virtual-machine
  135.                  true
  136.                  t-copyright-notice
  137.                  '()))
  138.  
  139. (define (INITIALIZE-VIRTUAL-MACHINE system)
  140.   (ignore system)
  141.   ;; Set the break-level to 0 so that the second level prompt will
  142.   ;; be printed if an error occurs during re-initialization.
  143.   ;; During initialization this is redundant.
  144.   (set *break-level*    0)
  145.   (if (gc-present?) (initialize-areas)))
  146.  
  147. (define (re-initialize-virtual-machine system)
  148.   (ignore system)
  149.   (initialize-condition-system)
  150.   (initialize-standard-ports)
  151.   (re-initialize object-hash)
  152.   (if (gc-present?) (initialize-areas)))
  153.  
  154. ;;; Both the loader and file system stuff must be available
  155. ;;; before executing BOOT-ADJUST-INITIAL-UNITS.
  156.  
  157. (define (REALLY-INITIALIZE-SYSTEMS INITIALIZER)
  158.   (print (car *embedded-systems*) (standard-output))
  159.   (let ((systems (reverse *embedded-systems*)))
  160.     (walk1 initializer systems)
  161.     (walk1 configure-system systems))
  162.   (no-value))
  163.  
  164. (define (INITIALIZE-SYSTEMS)
  165.   (really-initialize-systems initialize))
  166.  
  167. (define (RE-INITIALIZE-SYSTEMS)
  168.   (really-initialize-systems re-initialize))
  169.  
  170. ;++ where should this stuff go?
  171. ;(define tvm-env      (make-base-environment 'tvm-env))
  172. ;(define t-system-env (make-locale tvm-env 't-system-env))
  173. ;(define t-implementation-env t-system-env)
  174.  
  175. (define t-implementation-env
  176.   (make-base-environment 't-implementation-env))
  177. (define tvm-env      t-implementation-env)
  178. (define t-system-env tvm-env)
  179.  
  180. (initialize-condition-system)
  181. (initialize-weak-alist-pool)
  182.